COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		SUBROUTINE TRNSP(IT,TR)
C00016 ENDMK
C⊗;
	SUBROUTINE TRNSP(IT,TR)
	COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1) 
	COMMON/STF/RSTFAC(-3/4),RSTJ2
	COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
	1,LC,LPG,MPG,ZCLEF,SIG,LB,SPG,MTR1,MTR2
 	1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,RNAM3
	1 /LLL/LEND,NO1,NO2,NO3,XSIG

	SLUR=0
	PRX=99
	MS=200
	TTR=AMOD(TR,7.0)
	K=1
	IF(SIG.NE.-99)GO TO 199
C  FOUND KSIG, SO DON'T DO THE REST
41	IF(TTR.EQ.0)GO TO 199
C  WHAT DOES TTR DO???
	IF(XSIG.NE.0)GO TO 199
	NSIG=-1
	TYPE 42
42	FORMAT(' ADD KEY SIG? -- ',$)
43	FORMAT(A1)
	ACCEPT 43,XSIG
299	IF(XSIG.NE.'Y')GO TO 199
	NSIG=0

C  ***** NEXT FOR KEY SIG. ********
399	IF(TR)GO TO 2001
C  ADD= ADD OR SUBTR. # OR b  FROM KSIG.
	ADD=2
	IF(TR.EQ.4)ADD=1
	IF(TR.EQ.2)ADD=-3
C 4=F, 3=G, 2=A, -2=E FLAT, 1=Bb, 8=BBb, -1=D
	IF(TR.EQ.3)ADD=-1
	GO TO 2002
2001	ADD=3
	IF(TR.EQ.-1)ADD=-2
2002	IF(TTR.EQ.0)ADD=0
	R=0
	IF(SIG.NE.-99)R=SIG
	R=ADD+R
	IF(SIG.EQ.-99)CALL STAFF
	1 (4.,17.,4.0*RSTJ2,0,R,CLEF,0,0,0,0,0,0)
	SIG=R
199	X=CODEN(KPN,K,Q,J)
	IF(X.EQ.1)GO TO 1
	IF(X.NE.3)GO TO 2
	CLEF=Q(J+5)
	IF(Q(J).LT.3)CLEF=0
	IF(TR.NE.4)GO TO 21
C NEXT FOR HORN IN F CLEF CHANGES
	IF(CLEF.GE.100)CLEF=CLEF-100
C HORN CLEF CHANGES ARE KEPT, BS. CL'S ARE THROWN AWAY
21	IF(TR.NE.8)GO TO 100
C  NEXT FOR BASS CL. CLEF CHANGES.
	IF(CLEF.NE.0)Q(J+5)=0
	IF(CLEF.LT.100)GO TO 100
CC	Q(J+1)=1089.
	CALL SHRNK(K,IT)
C  MAKE IT INVISIBLE IF IT WAS MINI.
	CLEF=CLEF-100
	GO TO 199
2	IF(X.NE.4)GO TO 20
	BAR=-1
	MS=200
	GO TO 100
20	IF(X.NE.17)GO TO 12
C  HOW ABOUT CHANGE TO NO SIG?  OK, CODE =99
	NSIG=0
12	IF(X.EQ.5)GO TO 120
	IF(X.NE.6)GO TO 100
120	RT=TR
	IF(RT.NE.8)GO TO 121
	IF(CLEF.EQ.1)RT=-4
121	Q(J+4)=Q(J+4)+RT
	Q(J+5)=Q(J+5)+RT
	IF(X.EQ.5)SLUR=Q(J+6)
C  SAVES RIGHT POS. OF SLUR
	GO TO 100
C  FOR BEAMS AND SLURS

C**	IF(TR.NE.4)GO TO 21
C NEXT FOR HORN IN F CLEF CHANGES
C**	IF(CLEF.GE.100)CLEF=CLEF-100
C HORN CLEF CHANGES ARE KEPT, BS. CL'S ARE THROWN AWAY
C**21	IF(TR.NE.8)GO TO 100
C  NEXT FOR BASS CL. CLEF CHANGES.
C**	IF(CLEF.LT.100)GO TO 100
C  MAKE IT INVISIBLE IF IT WAS MINI.
C**	CLEF=CLEF-100
C**	GO TO 199
CS1000	RT=TR
1	RT=TR
	R=Q(J+4)
	RX=AMOD(R,100.0)
	RZ=AMOD(RX,7.0)
C  THE NOTE NUM
	IF(RZ)RZ=RZ+7
C  PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
	R5=Q(J+5)
	A=AMOD(R5,10.0)
C  THE ACCI
	RN(MS)=A
	RN(MS+1)=RX
C  SAVE FOR REPEATS
	MS=MS+2
	CHNAT=3
CS	IF(MS.LT.4)GO TO 205
	IF(MS.LT.203)GO TO 205
	N=MS-3
200	IF(RX.NE.RN(N))GO TO 201
	IF(A.EQ.0)GO TO 204
C  NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
	IF(A.EQ.RN(N-1))GO TO 204
	GO TO 203
204	IF(TR.NE.8)GO TO 4
	IF(CLEF.EQ.1)RT=RT-12
C  FOR BSCLAR
	GO TO 4
201	N=N-2
	IF(N.GE.200)GO TO 200
205	IF(NSIG)CHNAT=0
203	ADD=A
C  THE CHANGE IN ACCI
	IF(PRX.NE.RX)GO TO 44
C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
	IF(A.NE.0)GO TO 44
C NOW SAME NOTE, NO ACCI
	IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
C  FOUND CONNECTING TIE
CC	IF(BAR.EQ.0)GO TO 204
C THIS ↑↑↑↑ ALWAYS PUTS ACCI AFTER A BAR -- EVEN WITH TIE------
C OR SET MS BACK TO 200 WHEN TIE IS PRESENT.  THIS WILL
CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
	IF(BAR)MS=200
	GO TO 204
44	IF(NSIG)GO TO 440
	IF(A.EQ.0)GO TO 443
C  ONLY CHECKS ON NOTES WITH NO ACCI

440	IF(TR.NE.1)GO TO 5
C  NEXT FOR B-FLAT TRANSPOSITIONS
9	IF(RZ.EQ.0)GO TO 7
	IF(RZ.NE.3)GO TO 4
C NOW FOUND A B OR E
7	IF(A.EQ.0)GO TO 402
	IF(A.EQ.3)GO TO 402
C  CHNG NO ACCI OR NAT TO SHARP
	IF(A.EQ.4)GO TO 401
C 4=bb   5=##
	IF(A.EQ.2)GO TO 405
CC71	IF(A.EQ.1)GO TO 30
C  CHNG FLAT TO NAT.
C  NEXT FOR B#, E#
CC	RT=RT+1
C  MOVE IT UP A STEP
30	ADD=CHNAT
C  MAKE IT NAT. IF NEEDED
3	Q(J+5)=R5-A+ADD
4	PRX=RX
C  REAL NOTE LEVEL
40	Q(J+4)=R+RT
	BAR=0
100	IF(K.GE.IT)GO TO 499
	K=K+1
	GO TO 199

443	IF(CLEF.NE.1)GO TO 4

5	IF(TR.NE.4)GO TO 6
C FOUND "F" TRANS.
	IF(CLEF.EQ.1)GO TO 60
C  MAKE ADJUSTMENT FOR BASS CLEF
8	IF(RZ.EQ.0)GO TO 7
	GO TO 4

6	IF(TR.NE.8)GO TO 10
C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
	IF(CLEF.NE.1)GO TO 61
60	RZ=RZ-5
	IF(RZ)RZ=RZ+7
	IF(TR.EQ.4)GO TO 8
	RT=RT-12
61	IF(NSIG)GO TO 9
	IF(A.NE.0)GO TO 9
	GO TO 4

10	IF(TR.NE.2)GO TO 11
	IF(RZ.EQ.1)GO TO 101
	IF(RZ.EQ.4)GO TO 101
	IF(RZ.NE.5)GO TO 4
C  FOR "A".  FINDS C,F AND G.
101	IF(A.EQ.0)GO TO 401
	IF(A.EQ.2)GO TO 30
	IF(A.EQ.3)GO TO 401
	IF(A.EQ.5)GO TO 402
C  WON'T HANDLE Gbb→Ab
404	ADD=4
	GO TO 3
401	ADD=1
	GO TO 3

11	IF(TR.NE.3)GO TO 110
C  "G"   F→Bb, F#→B NAT.
	IF(RZ.NE.4)GO TO 4
	GO TO 101

110	IF(TR.NE.-2)GO TO 210
C  FOR Eb TRNS
	IF(RZ.EQ.3)GO TO 7
	IF(RZ.EQ.0)GO TO 7
	IF(RZ.NE.6)GO TO 4
	IF(A.EQ.5)GO TO 4
	GO TO 7
402	ADD=2
	GO TO 3
405	ADD=5
	GO TO 3
210	IF(TR.NE.-1)GO TO 4
C  IF NOT -1 IT IS NOW THOUGHT TO BE SOME OCTAVE SHIFT.
	IF(RZ.NE.1.AND.RZ.NE.4)GO TO 4
	GO TO 101
499	CALL RVRS(IT)
C  TO REVERSE STEMS, BEAMS AND SLURS
	END



	SUBROUTINE RVRS(IT)
	COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
	K=1

1	J=KPN(K)
	R=Q(J+1)
	IF(R.NE.1)GO TO 2
C  JUMP IF NOT A NOTE
	IF(Q(J+5).LT.10)GO TO 10
C  JUMP IF NO STEM ON IT
	KK=K+1
3	IF(KK.GT.IT)RETURN
	JJ=KPN(KK)
	RR=Q(JJ+1)
	IF(RR.NE.1)GO TO 5
C  JUMP IF NOT A NOTE
	IF(Q(JJ+5).GE.10)GO TO 6
C SKIP CHORD NOTES (NO STEM)
7	KK=KK+1
	GO TO 3
C DID NOT FIND BEAM NEARBY
6	RZ=AMOD(Q(J+4),100.0)
	N=J+5
	A=10
	IF(RZ.GE.7)GO TO 60
	IF(Q(N).LT.20)GO TO 10
C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
	A=-A
	GO TO 15
60	IF(Q(N).GE.20)GO TO 10
C  THERE MUST BE A BETTER WAY!
15	Q(N)=Q(N)+A
	GO TO 10
8	IF(Q(N).LT.20)GO TO 10
	A=-A
C  STEM UP
	GO TO 15
5	IF(RR.NE.6)GO TO 6
20	B=Q(JJ+4)
	C=Q(JJ+5)
	D=(B+C)/2.
	IF(RR.EQ.5)GO TO 9
	IF(RR.NE.6)GO TO 10
	B=Q(JJ+6)+1.
C  SAVES RANGE OF BEAM +1.
	IF(Q(JJ+7).GE.20)GO TO 11
C  NOW STEMS ARE UP
	IF(D.LT.7)GO TO 12
C JUMP TO 12 IF ALL OK
CC	C=-10
	JSTM=0 
C SAVE FOR REVERSED STEMS
	GO TO 23
11	IF(D.GE.7.)GO TO 12
C  STEMS DOWN
C JUMP IF NO REVERSE NEEDED
	JSTM=-1
23	JH=0
	CHNG=0
	DO 16 N=K,IT
	KK=KPN(N)
	IF(Q(KK+3).GT.B)GO TO 140
	R=Q(KK+1)
	IF(R.NE.1)GO TO 17
	L=5
	R=Q(KK+8)
C  THE STEM LENGTH
	IF(R.EQ.999)R=0
	Q(KK+8)=-R
C  FOR THE INVERSION
19	C=10.
	A=Q(KK+L)
	IF(A.GE.20)C=-C
	Q(KK+L)=C+A
	IF(JH.NE.0)GO TO 161
C NEXT FOR 1ST NOTE UNDER BEAM
	JH=4
160	R=Q(JJ+JH)-Q(KK+4)
	C=-1 
	IF(JSTM)GO TO 163
	C=R
	R=1
C NOW STEMS UP
163	IF(R.GT.C)GO TO 162
C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
	CHNG=C-R
	IF(JSTM.EQ.0)CHNG=-CHNG
	JH=JJ+4
	Q(JH)=Q(JH)+CHNG
	JH=JH+1
	Q(JH)=Q(JH)+CHNG
162	IF(L)GO TO 141
C  FOR ESCAPE FROM LOOP
161	JH=KK
C  JH SAVES PTR TO LAST NOTE UNDER BEAM
	GO TO 16
17	IF(R.NE.6)GO TO 18
C NOW IT'S A BEAM
	L=7
	GO TO 19
18	IF(R.NE.5)GO TO 16
C NOW IT'S A SLUR
	C=-4
	IF(Q(KK+7))C=-C
	CALL SLRV(KK,C)
C  TO REVERSE SLUR
CC	Q(KK+7)=-Q(KK+7)
16	CONTINUE
C  SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
140	KK=JH
	L=-1
	JH=5
C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
	GO TO 160

141	IF(CHNG.EQ.0)GO TO 14
	IF(CHNG)CHNG=-CHNG
	DO 142 N=K,IT
C  TO READJUST STEMS UNDER REVERSED BEAMS
	KK=KPN(N)
	IF(Q(KK+3).GT.B)GO TO 14
	IF(Q(KK+1).NE.1)GO TO 142
	Q(KK+8)=Q(KK+8)+CHNG
C  THE STEM LENGTH
142	CONTINUE
	GO TO 14

C NEXT FOR SLURS
9	B=-4
	IF(Q(JJ+7))GO TO 24
	IF(D.GT.7)GO TO 10
C JUMP TO LEAVE STEM UP
	GO TO 25
24	IF(D.LT.5)GO TO 10
C JUMP TO LEAVE STEM DOWN
	B=-B
CC25	Q(JJ+4)=Q(JJ+4)+B
CC	Q(JJ+5)=Q(JJ+5)+B
CC	Q(JJ+7)=-R
25	CALL SLRV(JJ,B)
	GO TO 10
12	DO 13 N=K+1,IT
	KK=KPN(N)
13	IF(Q(KK+3).GT.B)GO TO 14
C  JUMP OUT WHEN PAST END OF BEAM.
14	K=N-1
	GO TO 10

2	IF(R.NE.6)GO TO 21
22	JJ=J
	RR=R
	GO TO 20
21	IF(R.EQ.5)GO TO 22
10	IF(K.GT.IT)RETURN
	K=K+1
	GO TO 1
	END